home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume1 / xlisp1.4 / part4 < prev    next >
Encoding:
Internet Message Format  |  1986-11-30  |  46.2 KB
  1. Date: Wed, 13 Mar 85 16:58:41 pst
  2. From: decvax!ucbvax!UCBJADE!ucbjade:mwm (Mike Meyer)
  3. Subject: XLISP 1.4 part 4 (of 4)
  4.  
  5.  
  6. #! /bin/sh
  7. # This is a shell archive, meaning:
  8. # 1. Remove everything above the #! /bin/sh line.
  9. # 2. Save the resulting text in a file.
  10. # 3. Execute the file with /bin/sh (not csh) to create the files:
  11. #    Makefile
  12. #    fact.lsp
  13. #    init.lsp
  14. #    object.lsp
  15. #    prolog.lsp
  16. #    trace.lsp
  17. #    xlbind.c
  18. #    xldbug.c
  19. #    xlisp.h
  20. #    xlsetf.c
  21. #    xlstr.c
  22. #    xlstub.c.XXX
  23. #    xlsubr.c
  24. #    xlsym.c
  25. #    xlsys.c
  26. # This archive created: Mon Dec  2 10:01:12 1985
  27. export PATH; PATH=/bin:$PATH
  28. echo shar: extracting "'Makefile'" '(921 characters)'
  29. if test -f 'Makefile'
  30. then
  31.     echo shar: will not over-write existing file "'Makefile'"
  32. else
  33. sed 's/^X//' << \SHAR_EOF > 'Makefile'
  34. XSRC1=    xlobj.c xllist.c xlcont.c xlbfun.c
  35. XSRC2=    xldmem.c xleval.c xlfio.c xlftab.c xlglob.c xlio.c xlisp.c xljump.c \
  36.     xlmath.c xlprin.c xlread.c xlinit.c
  37. XSRC3=    xlsetf.c xlstr.c xlsubr.c xlsym.c xlsys.c xlbind.c xldbug.c
  38. XSRCS=    $(SRC1) $(SRC2) $(SRC3) xlisp.h
  39.  
  40. OBJS=    xlbfun.o xlbind.o xlcont.o xldbug.o xldmem.o xleval.o xlfio.o \
  41.     xlftab.o xlglob.o xlinit.o xlio.o xlisp.o xljump.o xllist.o xlmath.o \
  42.     xlobj.o xlprin.o xlread.o xlsetf.o xlstr.o xlsubr.o xlsym.o xlsys.o 
  43. MISC=    Makefile fact.lsp init.lsp object.lsp prolog.lsp trace.lsp \
  44.     xlstub.c.NOTUSED 
  45.  
  46. CFLAGS=    -O
  47.  
  48. xlisp: $(OBJS)
  49.     cc -o xlisp $(CFLAGS) $(OBJS)
  50.  
  51. $(OBJS): xlisp.h
  52.  
  53. rcs: $(SRCS)
  54.     rcs -l $?
  55.     touch rcs
  56.  
  57. lint:
  58.     lint -ach $(SRCS)
  59.  
  60. new: clean
  61.     rm -f xlisp
  62.     make xlisp
  63.  
  64. clean:
  65.     rm -f *.o
  66.  
  67. shar: $(SRCS) $(MISC)
  68.     shar -c -v xlisp.doc > xlisp1.shar
  69.     shar -c -v $(SRC1) > xlisp2.shar
  70.     shar -c -v $(SRC2) > xlisp3.shar
  71.     shar -c -v $(SRC3) $(MISC) > xlisp4.shar
  72. SHAR_EOF
  73. if test 921 -ne "`wc -c < 'Makefile'`"
  74. then
  75.     echo shar: error transmitting "'Makefile'" '(should have been 921 characters)'
  76. fi
  77. fi # end of overwriting check
  78. echo shar: extracting "'fact.lsp'" '(84 characters)'
  79. if test -f 'fact.lsp'
  80. then
  81.     echo shar: will not over-write existing file "'fact.lsp'"
  82. else
  83. sed 's/^X//' << \SHAR_EOF > 'fact.lsp'
  84. (defun factorial (n)
  85.        (cond ((= n 1) 1)
  86.          (t (* n (factorial (- n 1))))))
  87. SHAR_EOF
  88. if test 84 -ne "`wc -c < 'fact.lsp'`"
  89. then
  90.     echo shar: error transmitting "'fact.lsp'" '(should have been 84 characters)'
  91. fi
  92. fi # end of overwriting check
  93. echo shar: extracting "'init.lsp'" '(1959 characters)'
  94. if test -f 'init.lsp'
  95. then
  96.     echo shar: will not over-write existing file "'init.lsp'"
  97. else
  98. sed 's/^X//' << \SHAR_EOF > 'init.lsp'
  99. ; get some more memory
  100. (expand 1)
  101.  
  102. ; some fake definitions for Common Lisp pseudo compatiblity
  103. (setq symbol-function symbol-value)
  104. (setq fboundp boundp)
  105. (setq first car)
  106. (setq second cadr)
  107. (setq rest cdr)
  108.  
  109. ; some more cxr functions
  110. (defun caddr (x) (car (cddr x)))
  111. (defun cadddr (x) (cadr (cddr x)))
  112.  
  113. ; (when test code...) - execute code when test is true
  114. (defmacro when (test &rest code)
  115.           `(cond (,test ,@code)))
  116.  
  117. ; (unless test code...) - execute code unless test is true
  118. (defmacro unless (test &rest code)
  119.           `(cond ((not ,test) ,@code)))
  120.  
  121. ; (makunbound sym) - make a symbol be unbound
  122. (defun makunbound (sym) (setq sym '*unbound*) sym)
  123.  
  124. ; (objectp expr) - object predicate
  125. (defun objectp (x) (eq (type x) 'OBJ))
  126.  
  127. ; (filep expr) - file predicate
  128. (defun filep (x) (eq (type x) 'FPTR))
  129.  
  130. ; (unintern sym) - remove a symbol from the oblist
  131. (defun unintern (sym) (cond ((member sym *oblist*)
  132.                              (setq *oblist* (delete sym *oblist*))
  133.                              t)
  134.                             (t nil)))
  135.  
  136. ; (mapcan ...)
  137. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  138.  
  139. ; (mapcon ...)
  140. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  141.  
  142. ; (save fun) - save a function definition to a file
  143. (defun save (fun)
  144.        (let* ((fname (strcat (symbol-name fun) ".lsp"))
  145.               (fp (openo fname)))
  146.              (cond (fp (print (cons (if (eq (car (eval fun)) 'lambda)
  147.                                         'defun
  148.                                         'defmacro)
  149.                                     (cons fun (cdr (eval fun)))) fp)
  150.                        (close fp)
  151.                        fname)
  152.                    (t nil))))
  153.  
  154. ; (debug) - enable debug breaks
  155. (defun debug ()
  156.        (setq *breakenable* t))
  157.  
  158. ; (nodebug) - disable debug breaks
  159. (defun nodebug ()
  160.        (setq *breakenable* nil))
  161.  
  162. ; initialize to enable breaks but no trace back
  163. (setq *breakenable* t)
  164. (setq *tracenable* nil)
  165. SHAR_EOF
  166. if test 1959 -ne "`wc -c < 'init.lsp'`"
  167. then
  168.     echo shar: error transmitting "'init.lsp'" '(should have been 1959 characters)'
  169. fi
  170. fi # end of overwriting check
  171. echo shar: extracting "'object.lsp'" '(2374 characters)'
  172. if test -f 'object.lsp'
  173. then
  174.     echo shar: will not over-write existing file "'object.lsp'"
  175. else
  176. sed 's/^X//' << \SHAR_EOF > 'object.lsp'
  177. ; This is an example using the object-oriented programming support in
  178. ; XLISP.  The example involves defining a class of objects representing
  179. ; dictionaries.  Each instance of this class will be a dictionary in
  180. ; which names and values can be stored.  There will also be a facility
  181. ; for finding the values associated with names after they have been
  182. ; stored.
  183.  
  184. ; Create the 'Dictionary' class.
  185.  
  186. (setq Dictionary (Class 'new))
  187.  
  188. ; Establish the instance variables for the new class.
  189. ; The variable 'entries' will point to an association list representing the
  190. ; entries in the dictionary instance.
  191.  
  192. (Dictionary 'ivars '(entries))
  193.  
  194. ; Setup the method for the 'isnew' initialization message.
  195. ; This message will be send whenever a new instance of the 'Dictionary'
  196. ; class is created.  Its purpose is to allow the new instance to be
  197. ; initialized before any other messages are sent to it.  It sets the value
  198. ; of 'entries' to nil to indicate that the dictionary is empty.
  199.  
  200. (Dictionary 'answer 'isnew '()
  201.         '((setq entries nil)
  202.           self))
  203.  
  204. ; Define the message 'add' to make a new entry in the dictionary.  This
  205. ; message takes two arguments.  The argument 'name' specifies the name
  206. ; of the new entry; the argument 'value' specifies the value to be
  207. ; associated with that name.
  208.  
  209. (Dictionary 'answer 'add '(name value)
  210.         '((setq entries
  211.                 (cons (cons name value) entries))
  212.           value))
  213.  
  214. ; Create an instance of the 'Dictionary' class.  This instance is an empty
  215. ; dictionary to which words may be added.
  216.  
  217. (setq d (Dictionary 'new))
  218.  
  219. ; Add some entries to the new dictionary.
  220.  
  221. (d 'add 'mozart 'composer)
  222. (d 'add 'winston 'computer-scientist)
  223.  
  224. ; Define a message to find entries in a dictionary.  This message takes
  225. ; one argument 'name' which specifies the name of the entry for which to
  226. ; search.  It returns the value associated with the entry if one is
  227. ; present in the dictionary.  Otherwise, it returns nil.
  228.  
  229. (Dictionary 'answer 'find '(name &aux entry)
  230.         '((cond ((setq entry (assoc name entries))
  231.           (cdr entry))
  232.          (t
  233.           nil))))
  234.  
  235. ; Try to find some entries in the dictionary we created.
  236.  
  237. (d 'find 'mozart)
  238. (d 'find 'winston)
  239. (d 'find 'bozo)
  240.  
  241. ; The names 'mozart' and 'winston' are found in the dictionary so their
  242. ; values 'composer' and 'computer-scientist' are returned.  The name 'bozo'
  243. ; is not found so nil is returned in this case.
  244. SHAR_EOF
  245. if test 2374 -ne "`wc -c < 'object.lsp'`"
  246. then
  247.     echo shar: error transmitting "'object.lsp'" '(should have been 2374 characters)'
  248. fi
  249. fi # end of overwriting check
  250. echo shar: extracting "'prolog.lsp'" '(4289 characters)'
  251. if test -f 'prolog.lsp'
  252. then
  253.     echo shar: will not over-write existing file "'prolog.lsp'"
  254. else
  255. sed 's/^X//' << \SHAR_EOF > 'prolog.lsp'
  256.  
  257. ;; The following is a tiny Prolog interpreter in MacLisp
  258. ;; written by Ken Kahn and modified for XLISP by David Betz.
  259. ;; It was inspired by other tiny Lisp-based Prologs of
  260. ;; Par Emanuelson and Martin Nilsson.
  261. ;; There are no side-effects anywhere in the implementation.
  262. ;; Though it is VERY slow of course.
  263.  
  264. (defun prolog (database &aux goal)
  265.        (do () ((not (progn (princ "Query?") (setq goal (read)))))
  266.               (prove (list (rename-variables goal '(0)))
  267.                      '((bottom-of-environment))
  268.                      database
  269.                      1)))
  270.  
  271. ;; prove - proves the conjunction of the list-of-goals
  272. ;;         in the current environment
  273.  
  274. (defun prove (list-of-goals environment database level)
  275.       (cond ((null list-of-goals) ;; succeeded since there are no goals
  276.              (print-bindings environment environment)
  277.              (not (y-or-n-p "More?")))
  278.             (t (try-each database database
  279.                          (cdr list-of-goals) (car list-of-goals)
  280.                          environment level))))
  281.  
  282. (defun try-each (database-left database goals-left goal environment level 
  283.                  &aux assertion new-enviroment)
  284.        (cond ((null database-left) nil) ;; fail since nothing left in database
  285.              (t (setq assertion
  286.                       (rename-variables (car database-left)
  287.                                         (list level)))
  288.                 (setq new-environment
  289.                       (unify goal (car assertion) environment))
  290.                 (cond ((null new-environment) ;; failed to unify
  291.                        (try-each (cdr database-left) database
  292.                                  goals-left goal
  293.                                  environment level))
  294.                       ((prove (append (cdr assertion) goals-left)
  295.                               new-environment
  296.                               database
  297.                               (+ 1 level)))
  298.                       (t (try-each (cdr database-left) database
  299.                                    goals-left goal
  300.                                    environment level))))))
  301.  
  302. (defun unify (x y environment &aux new-environment)
  303.        (setq x (value x environment))
  304.        (setq y (value y environment))
  305.        (cond ((variable-p x) (cons (list x y) environment))
  306.              ((variable-p y) (cons (list y x) environment))
  307.              ((or (atom x) (atom y))
  308.                   (cond ((equal x y) environment)
  309.                         (t nil)))
  310.              (t (setq new-environment (unify (car x) (car y) environment))
  311.                 (cond (new-environment (unify (cdr x) (cdr y) new-environment))
  312.                   (t nil)))))
  313.  
  314. (defun value (x environment &aux binding)
  315.        (cond ((variable-p x)
  316.               (setq binding (assoc x environment))
  317.               (cond ((null binding) x)
  318.                     (t (value (cadr binding) environment))))
  319.              (t x)))
  320.  
  321. (defun variable-p (x)
  322.        (and x (listp x) (eq (car x) '?)))
  323.  
  324. (defun rename-variables (term list-of-level)
  325.        (cond ((variable-p term) (append term list-of-level))
  326.              ((atom term) term)
  327.              (t (cons (rename-variables (car term) list-of-level)
  328.                       (rename-variables (cdr term) list-of-level)))))
  329.  
  330. (defun print-bindings (environment-left environment)
  331.        (cond ((cdr environment-left)
  332.               (cond ((= 0 (nth 2 (caar environment-left)))
  333.                      (prin1 (cadr (caar environment-left)))
  334.                      (princ " = ")
  335.                      (print (value (caar environment-left) environment))))
  336.               (print-bindings (cdr environment-left) environment))))
  337.  
  338. ;; a sample database:
  339. (setq db '(((father madelyn ernest))
  340.            ((mother madelyn virginia))
  341.        ((father david arnold))
  342.        ((mother david pauline))
  343.        ((father rachel david))
  344.        ((mother rachel madelyn))
  345.            ((grandparent (? grandparent) (? grandchild))
  346.             (parent (? grandparent) (? parent))
  347.             (parent (? parent) (? grandchild)))
  348.            ((parent (? parent) (? child))
  349.             (mother (? parent) (? child)))
  350.            ((parent (? parent) (? child))
  351.             (father (? parent) (? child)))))
  352.  
  353. ;; the following are utilities
  354. (defun y-or-n-p (prompt)
  355.        (princ prompt)
  356.        (eq (read) 'y))
  357.  
  358. ;; start things going
  359. (prolog db)
  360. SHAR_EOF
  361. if test 4289 -ne "`wc -c < 'prolog.lsp'`"
  362. then
  363.     echo shar: error transmitting "'prolog.lsp'" '(should have been 4289 characters)'
  364. fi
  365. fi # end of overwriting check
  366. echo shar: extracting "'trace.lsp'" '(642 characters)'
  367. if test -f 'trace.lsp'
  368. then
  369.     echo shar: will not over-write existing file "'trace.lsp'"
  370. else
  371. sed 's/^X//' << \SHAR_EOF > 'trace.lsp'
  372. (setq *tracelist* nil)
  373.  
  374. (defun evalhookfcn (expr &aux val)
  375.        (if (and (consp expr) (member (car expr) *tracelist*))
  376.            (progn (princ ">>> ") (print expr)
  377.                   (setq val (evalhook expr evalhookfcn nil))
  378.                   (princ "<<< ") (print val))
  379.            (evalhook expr evalhookfcn nil)))
  380.  
  381. (defun trace (fun)
  382.        (if (not (member fun *tracelist*))
  383.        (progn (setq *tracelist* (cons fun *tracelist*))
  384.                   (setq *evalhook* evalhookfcn)))
  385.        *tracelist*)
  386.  
  387. (defun untrace (fun)
  388.        (if (null (setq *tracelist* (delete fun *tracelist*)))
  389.            (setq *evalhook* nil))
  390.        *tracelist*)
  391. SHAR_EOF
  392. if test 642 -ne "`wc -c < 'trace.lsp'`"
  393. then
  394.     echo shar: error transmitting "'trace.lsp'" '(should have been 642 characters)'
  395. fi
  396. fi # end of overwriting check
  397. echo shar: extracting "'xlbind.c'" '(1509 characters)'
  398. if test -f 'xlbind.c'
  399. then
  400.     echo shar: will not over-write existing file "'xlbind.c'"
  401. else
  402. sed 's/^X//' << \SHAR_EOF > 'xlbind.c'
  403. /* xlbind - xlisp symbol binding routines */
  404.  
  405. #include "xlisp.h"
  406.  
  407. /* external variables */
  408. extern NODE *xlenv,*xlnewenv;
  409.  
  410. /* xlsbind - bind a value to a symbol sequentially */
  411. xlsbind(sym,val)
  412.   NODE *sym,*val;
  413. {
  414.     NODE *ptr;
  415.  
  416.     /* create a new environment list entry */
  417.     ptr = newnode(LIST);
  418.     rplacd(ptr,xlenv);
  419.     xlenv = ptr;
  420.  
  421.     /* create a new variable binding */
  422.     rplaca(ptr,newnode(LIST));
  423.     rplaca(car(ptr),sym);
  424.     rplacd(car(ptr),sym->n_symvalue);
  425.     sym->n_symvalue = val;
  426. }
  427.  
  428. /* xlbind - bind a value to a symbol in parallel */
  429. xlbind(sym,val)
  430.   NODE *sym,*val;
  431. {
  432.     NODE *ptr;
  433.  
  434.     /* create a new environment list entry */
  435.     ptr = newnode(LIST);
  436.     rplacd(ptr,xlnewenv);
  437.     xlnewenv = ptr;
  438.  
  439.     /* create a new variable binding */
  440.     rplaca(ptr,newnode(LIST));
  441.     rplaca(car(ptr),sym);
  442.     rplacd(car(ptr),val);
  443. }
  444.  
  445. /* xlfixbindings - make a new set of bindings visible */
  446. xlfixbindings()
  447. {
  448.     NODE *eptr,*bnd,*sym,*oldvalue;
  449.  
  450.     /* fix the bound value of each symbol in the environment chain */
  451.     for (eptr = xlnewenv; eptr != xlenv; eptr = cdr(eptr)) {
  452.     bnd = car(eptr);
  453.     sym = car(bnd);
  454.     oldvalue = sym->n_symvalue;
  455.     sym->n_symvalue = cdr(bnd);
  456.     rplacd(bnd,oldvalue);
  457.     }
  458.     xlenv = xlnewenv;
  459. }
  460.  
  461. /* xlunbind - unbind symbols bound in this environment */
  462. xlunbind(env)
  463.   NODE *env;
  464. {
  465.     NODE *bnd;
  466.  
  467.     /* unbind each symbol in the environment chain */
  468.     for (; xlenv != env; xlenv = cdr(xlenv))
  469.     if (bnd = car(xlenv))
  470.         car(bnd)->n_symvalue = cdr(bnd);
  471. }
  472. SHAR_EOF
  473. if test 1509 -ne "`wc -c < 'xlbind.c'`"
  474. then
  475.     echo shar: error transmitting "'xlbind.c'" '(should have been 1509 characters)'
  476. fi
  477. fi # end of overwriting check
  478. echo shar: extracting "'xldbug.c'" '(3924 characters)'
  479. if test -f 'xldbug.c'
  480. then
  481.     echo shar: will not over-write existing file "'xldbug.c'"
  482. else
  483. sed 's/^X//' << \SHAR_EOF > 'xldbug.c'
  484. /* xldebug - xlisp debugging support */
  485.  
  486. #include "xlisp.h"
  487.  
  488. /* external variables */
  489. extern long total;
  490. extern int xldebug;
  491. extern int xltrace;
  492. extern NODE *s_unbound;
  493. extern NODE *s_stdin,*s_stdout;
  494. extern NODE *s_tracenable,*s_tlimit,*s_breakenable;
  495. extern NODE *s_continue,*s_quit;
  496. extern NODE *xlstack;
  497. extern NODE *true;
  498. extern NODE **trace_stack;
  499.  
  500. /* external routines */
  501. extern char *malloc();
  502.  
  503. /* forward declarations */
  504. XFORWARD NODE *stacktop();
  505.  
  506. /* xlfail - xlisp error handler */
  507. xlfail(emsg)
  508.   char *emsg;
  509. {
  510.     xlerror(emsg,stacktop());
  511. }
  512.  
  513. /* xlabort - xlisp serious error handler */
  514. xlabort(emsg)
  515.   char *emsg;
  516. {
  517.     xlsignal(emsg,s_unbound);
  518. }
  519.  
  520. /* xlbreak - enter a break loop */
  521. xlbreak(emsg,arg)
  522.   char *emsg; NODE *arg;
  523. {
  524.     breakloop("break",NULL,emsg,arg,TRUE);
  525. }
  526.  
  527. /* xlerror - handle a fatal error */
  528. xlerror(emsg,arg)
  529.   char *emsg; NODE *arg;
  530. {
  531.     doerror(NULL,emsg,arg,FALSE);
  532. }
  533.  
  534. /* xlcerror - handle a recoverable error */
  535. xlcerror(cmsg,emsg,arg)
  536.   char *cmsg,*emsg; NODE *arg;
  537. {
  538.     doerror(cmsg,emsg,arg,TRUE);
  539. }
  540.  
  541. /* xlerrprint - print an error message */
  542. xlerrprint(hdr,cmsg,emsg,arg)
  543.   char *hdr,*cmsg,*emsg; NODE *arg;
  544. {
  545.     printf("%s: %s",hdr,emsg);
  546.     if (arg != s_unbound) { printf(" - "); stdprint(arg); }
  547.     else printf("\n");
  548.     if (cmsg) printf("if continued: %s\n",cmsg);
  549. }
  550.  
  551. /* doerror - handle xlisp errors */
  552. LOCAL doerror(cmsg,emsg,arg,cflag)
  553.   char *cmsg,*emsg; NODE *arg; int cflag;
  554. {
  555.     /* make sure the break loop is enabled */
  556.     if (s_breakenable->n_symvalue == NIL)
  557.     xlsignal(emsg,arg);
  558.  
  559.     /* call the debug read-eval-print loop */
  560.     breakloop("error",cmsg,emsg,arg,cflag);
  561. }
  562.  
  563. /* breakloop - the debug read-eval-print loop */
  564. LOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
  565.   char *hdr,*cmsg,*emsg; NODE *arg; int cflag;
  566. {
  567.     NODE *oldstk,expr,*val;
  568.     CONTEXT cntxt;
  569.  
  570.     /* increment the debug level */
  571.     xldebug++;
  572.  
  573.     /* flush the input buffer */
  574.     xlflush();
  575.  
  576.     /* print the error message */
  577.     xlerrprint(hdr,cmsg,emsg,arg);
  578.  
  579.     /* do the back trace */
  580.     if (s_tracenable->n_symvalue) {
  581.     val = s_tlimit->n_symvalue;
  582.     xlbaktrace(fixp(val) ? val->n_int : -1);
  583.     }
  584.  
  585.     /* create a new stack frame */
  586.     oldstk = xlsave(&expr,NULL);
  587.  
  588.     /* debug command processing loop */
  589.     xlbegin(&cntxt,CF_ERROR,true);
  590.     while (TRUE) {
  591.  
  592.     /* setup the continue trap */
  593.     if (setjmp(cntxt.c_jmpbuf)) {
  594.         xlflush();
  595.         continue;
  596.     }
  597.  
  598.     /* read an expression and check for eof */
  599.     if (!xlread(s_stdin->n_symvalue,&expr.n_ptr)) {
  600.         expr.n_ptr = s_quit;
  601.         break;
  602.     }
  603.  
  604.     /* check for commands */
  605.     if (expr.n_ptr == s_continue) {
  606.         if (cflag) break;
  607.         else xlabort("this error can't be continued");
  608.     }
  609.     else if (expr.n_ptr == s_quit)
  610.         break;
  611.  
  612.     /* evaluate the expression */
  613.     expr.n_ptr = xleval(expr.n_ptr);
  614.  
  615.     /* print it */
  616.     xlprint(s_stdout->n_symvalue,expr.n_ptr,TRUE);
  617.     xlterpri(s_stdout->n_symvalue);
  618.     }
  619.     xlend(&cntxt);
  620.  
  621.     /* restore the previous stack frame */
  622.     xlstack = oldstk;
  623.  
  624.     /* decrement the debug level */
  625.     xldebug--;
  626.  
  627.     /* continue the next higher break loop on quit */
  628.     if (expr.n_ptr == s_quit)
  629.     xlsignal("quit from break loop",s_unbound);
  630. }
  631.  
  632. /* tpush - add an entry to the trace stack */
  633. xltpush(nptr)
  634.     NODE *nptr;
  635. {
  636.     if (++xltrace < TDEPTH)
  637.     trace_stack[xltrace] = nptr;
  638. }
  639.  
  640. /* tpop - pop an entry from the trace stack */
  641. xltpop()
  642. {
  643.     xltrace--;
  644. }
  645.  
  646. /* stacktop - return the top node on the stack */
  647. LOCAL NODE *stacktop()
  648. {
  649.     return (xltrace >= 0 && xltrace < TDEPTH ? trace_stack[xltrace] : s_unbound);
  650. }
  651.  
  652. /* baktrace - do a back trace */
  653. xlbaktrace(n)
  654.   int n;
  655. {
  656.     int i;
  657.  
  658.     for (i = xltrace; (n < 0 || n--) && i >= 0; i--)
  659.     if (i < TDEPTH)
  660.         stdprint(trace_stack[i]);
  661. }
  662.  
  663. /* xldinit - debug initialization routine */
  664. xldinit()
  665. {
  666.     if ((trace_stack = (NODE **) malloc(TSTKSIZE)) == NULL)
  667.     xlabort("insufficient memory");
  668.     total += (long) TSTKSIZE;
  669.     xltrace = -1;
  670.     xldebug = 0;
  671. }
  672. SHAR_EOF
  673. if test 3924 -ne "`wc -c < 'xldbug.c'`"
  674. then
  675.     echo shar: error transmitting "'xldbug.c'" '(should have been 3924 characters)'
  676. fi
  677. fi # end of overwriting check
  678. echo shar: extracting "'xlisp.h'" '(8406 characters)'
  679. if test -f 'xlisp.h'
  680. then
  681.     echo shar: will not over-write existing file "'xlisp.h'"
  682. else
  683. sed 's/^X//' << \SHAR_EOF > 'xlisp.h'
  684. #include <stdio.h>
  685.  
  686.               /* xlisp - a small subset of lisp */
  687.  
  688.  
  689.             /* system specific definitions */
  690.  
  691. /* DEFEXT       define to enable default extension of '.lsp' on 'load' */
  692. /* FGETNAME     define if system supports 'fgetname' */
  693. /* NNODES       number of nodes to allocate in each request */
  694. /* xlisp - a small subset of lisp */
  695.  
  696. /* system specific definitions */
  697. #define UNIX
  698.  
  699. #ifdef AZTEC
  700. #include "stdio.h"
  701. #include "setjmp.h"
  702. #else
  703. #include <stdio.h>
  704. #include <setjmp.h>
  705. #include <ctype.h>
  706. #endif
  707.  
  708. /* NNODES       number of nodes to allocate in each request */
  709. /* TDEPTH       trace stack depth */
  710. /* FORWARD      type of a forward declaration (usually "") */
  711. /* LOCAL        type of a local function (usually "static") */
  712.  
  713. /* for the Computer Innovations compiler */
  714. #ifdef CI
  715. #define NNODES          1000
  716. #define TDEPTH          500
  717. #endif
  718.  
  719. /* for the CPM68K compiler */
  720. #ifdef CPM68K
  721. #define NNODES          1000
  722. #define TDEPTH          500
  723. #define LOCAL
  724. #define AFMT            "%lx"
  725. #undef NULL
  726. #define NULL            (char *)0
  727. #endif
  728.  
  729. /* for the DeSmet compiler */
  730. #ifdef DESMET
  731. #define NNODES          1000
  732. #define TDEPTH          500
  733. #define LOCAL
  734. #define getc(fp)        getcx(fp)
  735. #define putc(ch,fp)     putcx(ch,fp)
  736. #define EOF             -1
  737. #endif
  738.  
  739. /* for the MegaMax compiler */
  740. #ifdef MEGAMAX
  741. #define NNODES          200
  742. #define TDEPTH          100
  743. #define LOCAL
  744. #define AFMT            "%lx"
  745. #define TSTKSIZE        (4 * TDEPTH)
  746. #endif
  747.  
  748. /* for the VAX-11 C compiler */
  749. #ifdef vms
  750. #define NNODES          2000
  751. #define TDEPTH          1000
  752. #endif
  753.  
  754. /* for the DECUS C compiler */
  755. #ifdef decus
  756. #define NNODES          200
  757. #define TDEPTH          100
  758. #define FORWARD         extern
  759. #endif
  760.  
  761. /* for unix compilers */
  762. #ifdef unix
  763. #define NNODES          200
  764. #define TDEPTH          100
  765. #endif
  766.  
  767. /* for the AZTEC C compiler */
  768. #ifdef AZTEC
  769. #define NNODES          200
  770. #define TDEPTH          100
  771. #define getc(fp)        agetc(fp)
  772. #define putc(ch,fp)     aputc(ch,fp)
  773. #endif
  774.  
  775. /* default important definitions */
  776. #ifndef NNODES
  777. #define NNODES          200
  778. #endif
  779. #ifndef TDEPTH
  780. #define TDEPTH          100
  781. #endif
  782. #ifndef FORWARD
  783. #define FORWARD
  784. #endif
  785. #ifndef LOCAL
  786. #define LOCAL           static
  787. #endif
  788. #ifndef AFMT
  789. #define AFMT            "%x"
  790. #endif
  791. #ifndef TSTKSIZE
  792. #define TSTKSIZE        (sizeof(NODE *) * TDEPTH)
  793. #endif
  794.  
  795. /* useful definitions */
  796. #define TRUE    1
  797. #define FALSE   0
  798. #define NIL     (NODE *)0
  799.  
  800. /* program limits */
  801. #define STRMAX          100             /* maximum length of a string constant */
  802.         
  803. /* node types */
  804. #define FREE    0
  805. #define SUBR    1
  806. #define FSUBR   2
  807. #define LIST    3
  808. #define SYM     4
  809. #define INT     5
  810. #define STR     6
  811. #define OBJ     7
  812. #define FPTR    8
  813.  
  814. /* node flags */
  815. #define MARK    1
  816. #define LEFT    2
  817.  
  818. /* string types */
  819. #define DYNAMIC 0
  820. #define STATIC  1
  821.  
  822. /* new node access macros */
  823. #define ntype(x)        ((x)->n_type)
  824. #define atom(x)         ((x) == NIL || (x)->n_type != LIST)
  825. #define null(x)         ((x) == NIL)
  826. #define listp(x)        ((x) == NIL || (x)->n_type == LIST)
  827. #define consp(x)        ((x) && (x)->n_type == LIST)
  828. #define subrp(x)        ((x) && (x)->n_type == SUBR)
  829. #define fsubrp(x)       ((x) && (x)->n_type == FSUBR)
  830. #define stringp(x)      ((x) && (x)->n_type == STR)
  831. #define symbolp(x)      ((x) && (x)->n_type == SYM)
  832. #define filep(x)        ((x) && (x)->n_type == FPTR)
  833. #define objectp(x)      ((x) && (x)->n_type == OBJ)
  834. #define fixp(x)         ((x) && (x)->n_type == INT)
  835. #define car(x)          ((x)->n_car)
  836. #define cdr(x)          ((x)->n_cdr)
  837. #define rplaca(x,y)     ((x)->n_car = (y))
  838. #define rplacd(x,y)     ((x)->n_cdr = (y))
  839.  
  840. /* symbol node */
  841. #define n_symplist      n_info.n_xsym.xsy_plist
  842. #define n_symvalue      n_info.n_xsym.xsy_value
  843.  
  844. /* subr/fsubr node */
  845. #define n_subr          n_info.n_xsubr.xsu_subr
  846.  
  847. /* list node */
  848. #define n_car           n_info.n_xlist.xl_car
  849. #define n_cdr           n_info.n_xlist.xl_cdr
  850. #define n_ptr           n_info.n_xlist.xl_car
  851.  
  852. /* integer node */
  853. #define n_int           n_info.n_xint.xi_int
  854.  
  855. /* string node */
  856. #define n_str           n_info.n_xstr.xst_str
  857. #define n_strtype       n_info.n_xstr.xst_type
  858.  
  859. /* object node */
  860. #define n_obclass       n_info.n_xobj.xo_obclass
  861. #define n_obdata        n_info.n_xobj.xo_obdata
  862.  
  863. /* file pointer node */
  864. #define n_fp            n_info.n_xfptr.xf_fp
  865. #define n_savech        n_info.n_xfptr.xf_savech
  866.  
  867. /* node structure */
  868. typedef struct node {
  869.     char n_type;                /* type of node */
  870.     char n_flags;               /* flag bits */
  871.     union {                     /* value */
  872.         struct xsym {           /* symbol node */
  873.             struct node *xsy_plist;     /* symbol plist - (name . plist) */
  874.             struct node *xsy_value;     /* the current value */
  875.         } n_xsym;
  876.         struct xsubr {          /* subr/fsubr node */
  877.             struct node *(*xsu_subr)(); /* pointer to an internal routine */
  878.         } n_xsubr;
  879.         struct xlist {          /* list node (cons) */
  880.             struct node *xl_car;        /* the car pointer */
  881.             struct node *xl_cdr;        /* the cdr pointer */
  882.         } n_xlist;
  883.         struct xint {           /* integer node */
  884.             int xi_int;                 /* integer value */
  885.         } n_xint;
  886.         struct xstr {           /* string node */
  887.             int xst_type;               /* string type */
  888.             char *xst_str;              /* string pointer */
  889.         } n_xstr;
  890.         struct xobj {           /* object node */
  891.             struct node *xo_obclass;    /* class of object */
  892.             struct node *xo_obdata;     /* instance data */
  893.         } n_xobj;
  894.         struct xfptr {          /* file pointer node */
  895.             FILE *xf_fp;                /* the file pointer */
  896.             int xf_savech;              /* lookahead character for input files */
  897.         } n_xfptr;
  898.     } n_info;
  899. } NODE;
  900.  
  901. /* execution context flags */
  902. #define CF_GO           1
  903. #define CF_RETURN       2
  904. #define CF_THROW        4
  905. #define CF_ERROR        8
  906.  
  907. /* execution context */
  908. typedef struct context {
  909.     int c_flags;                        /* context type flags */
  910.     struct node *c_expr;                /* expression (type dependant) */
  911.     jmp_buf c_jmpbuf;                   /* longjmp context */
  912.     struct context *c_xlcontext;        /* old value of xlcontext */
  913.     struct node *c_xlstack;             /* old value of xlstack */
  914.     struct node *c_xlenv,*c_xlnewenv;   /* old values of xlenv and xlnewenv */
  915.     int c_xltrace;                      /* old value of xltrace */
  916. } CONTEXT;
  917.  
  918. /* function table entry structure */
  919. struct fdef {
  920.     char *f_name;                       /* function name */
  921.     int f_type;                         /* function type SUBR/FSUBR */
  922.     struct node *(*f_fcn)();            /* function code */
  923. };
  924.  
  925. /* memory segment structure definition */
  926. struct segment {
  927.     int sg_size;
  928.     struct segment *sg_next;
  929.     struct node sg_nodes[1];
  930. };
  931.  
  932. /* external procedure declarations */
  933. extern struct node *xleval();           /* evaluate an expression */
  934. extern struct node *xlapply();          /* apply a function to arguments */
  935. extern struct node *xlevlist();         /* evaluate a list of arguments */
  936. extern struct node *xlarg();            /* fetch an argument */
  937. extern struct node *xlevarg();          /* fetch and evaluate an argument */
  938. extern struct node *xlmatch();          /* fetch an typed argument */
  939. extern struct node *xlevmatch();        /* fetch and evaluate a typed arg */
  940. extern struct node *xlsend();           /* send a message to an object */
  941. extern struct node *xlenter();          /* enter a symbol */
  942. extern struct node *xlsenter();         /* enter a symbol with a static pname */
  943. extern struct node *xlintern();         /* intern a symbol */
  944. extern struct node *xlmakesym();        /* make an uninterned symbol */
  945. extern struct node *xlsave();           /* generate a stack frame */
  946. extern struct node *xlobsym();          /* find an object's class or instance
  947.                                            variable */
  948. extern struct node *xlgetprop();        /* get the value of a property */
  949. extern char *xlsymname();               /* get the print name of a symbol */
  950.  
  951. extern struct node *newnode();          /* allocate a new node */
  952. extern char *stralloc();                /* allocate string space */
  953. extern char *strsave();                 /* make a safe copy of a string */
  954.  
  955. SHAR_EOF
  956. if test 8406 -ne "`wc -c < 'xlisp.h'`"
  957. then
  958.     echo shar: error transmitting "'xlisp.h'" '(should have been 8406 characters)'
  959. fi
  960. fi # end of overwriting check
  961. echo shar: extracting "'xlsetf.c'" '(1884 characters)'
  962. if test -f 'xlsetf.c'
  963. then
  964.     echo shar: will not over-write existing file "'xlsetf.c'"
  965. else
  966. sed 's/^X//' << \SHAR_EOF > 'xlsetf.c'
  967. /* xlsetf - set field function */
  968.  
  969. #include "xlisp.h"
  970.  
  971. /* external variables */
  972. extern NODE *s_car,*s_cdr,*s_get,*s_svalue,*s_splist;
  973. extern NODE *xlstack;
  974.  
  975. /* xsetf - built-in function 'setf' */
  976. NODE *xsetf(args)
  977.   NODE *args;
  978. {
  979.     NODE *oldstk,arg,place,value;
  980.  
  981.     /* create a new stack frame */
  982.     oldstk = xlsave(&arg,&place,&value,NULL);
  983.  
  984.     /* initialize */
  985.     arg.n_ptr = args;
  986.  
  987.     /* handle each pair of arguments */
  988.     while (arg.n_ptr) {
  989.  
  990.     /* get place and value */
  991.     place.n_ptr = xlarg(&arg.n_ptr);
  992.     value.n_ptr = xlevarg(&arg.n_ptr);
  993.  
  994.     /* check the place form */
  995.     if (symbolp(place.n_ptr))
  996.         assign(place.n_ptr,value.n_ptr);
  997.     else if (consp(place.n_ptr))
  998.         placeform(place.n_ptr,value.n_ptr);
  999.     else
  1000.         xlfail("bad place form");
  1001.     }
  1002.  
  1003.     /* restore the previous stack frame */
  1004.     xlstack = oldstk;
  1005.  
  1006.     /* return the value */
  1007.     return (value.n_ptr);
  1008. }
  1009.  
  1010. /* placeform - handle a place form other than a symbol */
  1011. LOCAL placeform(place,value)
  1012.   NODE *place,*value;
  1013. {
  1014.     NODE *fun,*oldstk,arg1,arg2;
  1015.  
  1016.     /* check the function name */
  1017.     if ((fun = xlmatch(SYM,&place)) == s_get) {
  1018.     oldstk = xlsave(&arg1,&arg2,NULL);
  1019.     arg1.n_ptr = xlevmatch(SYM,&place);
  1020.     arg2.n_ptr = xlevmatch(SYM,&place);
  1021.     xllastarg(place);
  1022.     xlputprop(arg1.n_ptr,value,arg2.n_ptr);
  1023.     xlstack = oldstk;
  1024.     }
  1025.     else if (fun == s_svalue || fun == s_splist) {
  1026.     oldstk = xlsave(&arg1,NULL);
  1027.     arg1.n_ptr = xlevmatch(SYM,&place);
  1028.     xllastarg(place);
  1029.     if (fun == s_svalue)
  1030.         arg1.n_ptr->n_symvalue = value;
  1031.     else
  1032.         rplacd(arg1.n_ptr->n_symplist,value);
  1033.     xlstack = oldstk;
  1034.     }
  1035.     else if (fun == s_car || fun == s_cdr) {
  1036.     oldstk = xlsave(&arg1,NULL);
  1037.     arg1.n_ptr = xlevmatch(LIST,&place);
  1038.     xllastarg(place);
  1039.     if (consp(arg1.n_ptr))
  1040.         if (fun == s_car)
  1041.         rplaca(arg1.n_ptr,value);
  1042.         else
  1043.         rplacd(arg1.n_ptr,value);
  1044.     xlstack = oldstk;
  1045.     }
  1046.     else
  1047.     xlfail("bad place form");
  1048. }
  1049. SHAR_EOF
  1050. if test 1884 -ne "`wc -c < 'xlsetf.c'`"
  1051. then
  1052.     echo shar: error transmitting "'xlsetf.c'" '(should have been 1884 characters)'
  1053. fi
  1054. fi # end of overwriting check
  1055. echo shar: extracting "'xlstr.c'" '(4134 characters)'
  1056. if test -f 'xlstr.c'
  1057. then
  1058.     echo shar: will not over-write existing file "'xlstr.c'"
  1059. else
  1060. sed 's/^X//' << \SHAR_EOF > 'xlstr.c'
  1061. /* xlstr - xlisp string builtin functions */
  1062.  
  1063. #include "xlisp.h"
  1064.  
  1065. /* external variables */
  1066. extern NODE *xlstack;
  1067.  
  1068. /* external procedures */
  1069. extern char *strcat();
  1070.  
  1071. /* xstrlen - length of a string */
  1072. NODE *xstrlen(args)
  1073.   NODE *args;
  1074. {
  1075.     NODE *val;
  1076.     int total;
  1077.  
  1078.     /* initialize */
  1079.     total = 0;
  1080.  
  1081.     /* loop over args and total */
  1082.     while (args)
  1083.     total += strlen(xlmatch(STR,&args)->n_str);
  1084.  
  1085.     /* create the value node */
  1086.     val = newnode(INT);
  1087.     val->n_int = total;
  1088.  
  1089.     /* return the total */
  1090.     return (val);
  1091. }
  1092.  
  1093. /* xstrcat - concatenate a bunch of strings */
  1094. NODE *xstrcat(args)
  1095.   NODE *args;
  1096. {
  1097.     NODE *oldstk,val,*p;
  1098.     char *str;
  1099.     int len;
  1100.  
  1101.     /* create a new stack frame */
  1102.     oldstk = xlsave(&val,NULL);
  1103.  
  1104.     /* find the length of the new string */
  1105.     for (p = args, len = 0; p; )
  1106.     len += strlen(xlmatch(STR,&p)->n_str);
  1107.  
  1108.     /* create the result string */
  1109.     val.n_ptr = newnode(STR);
  1110.     val.n_ptr->n_str = str = stralloc(len);
  1111.     *str = 0;
  1112.  
  1113.     /* combine the strings */
  1114.     while (args)
  1115.     strcat(str,xlmatch(STR,&args)->n_str);
  1116.  
  1117.     /* restore the previous stack frame */
  1118.     xlstack = oldstk;
  1119.  
  1120.     /* return the new string */
  1121.     return (val.n_ptr);
  1122. }
  1123.  
  1124. /* xsubstr - return a substring */
  1125. NODE *xsubstr(args)
  1126.   NODE *args;
  1127. {
  1128.     NODE *oldstk,arg,src,val;
  1129.     int start,forlen,srclen;
  1130.     char *srcptr,*dstptr;
  1131.  
  1132.     /* create a new stack frame */
  1133.     oldstk = xlsave(&arg,&src,&val,NULL);
  1134.  
  1135.     /* initialize */
  1136.     arg.n_ptr = args;
  1137.     
  1138.     /* get string and its length */
  1139.     src.n_ptr = xlmatch(STR,&arg.n_ptr);
  1140.     srcptr = src.n_ptr->n_str;
  1141.     srclen = strlen(srcptr);
  1142.  
  1143.     /* get starting pos -- must be present */
  1144.     start = xlmatch(INT,&arg.n_ptr)->n_int;
  1145.  
  1146.     /* get length -- if not present use remainder of string */
  1147.     forlen = (arg.n_ptr ? xlmatch(INT,&arg.n_ptr)->n_int : srclen);
  1148.  
  1149.     /* make sure there aren't any more arguments */
  1150.     xllastarg(arg.n_ptr);
  1151.  
  1152.     /* don't take more than exists */
  1153.     if (start + forlen > srclen)
  1154.     forlen = srclen - start + 1;
  1155.  
  1156.     /* if start beyond string -- return null string */
  1157.     if (start > srclen) {
  1158.     start = 1;
  1159.     forlen = 0; }
  1160.     
  1161.     /* create return node */
  1162.     val.n_ptr = newnode(STR);
  1163.     val.n_ptr->n_str = dstptr = stralloc(forlen);
  1164.  
  1165.     /* move string */
  1166.     for (srcptr += start-1; forlen--; *dstptr++ = *srcptr++)
  1167.     ;
  1168.     *dstptr = 0;
  1169.  
  1170.     /* restore the previous stack frame */
  1171.     xlstack = oldstk;
  1172.  
  1173.     /* return the substring */
  1174.     return (val.n_ptr);
  1175. }
  1176.  
  1177. /* xascii - return ascii value */
  1178. NODE *xascii(args)
  1179.   NODE *args;
  1180. {
  1181.     NODE *val;
  1182.  
  1183.     /* build return node */
  1184.     val = newnode(INT);
  1185.     val->n_int = *(xlmatch(STR,&args)->n_str);
  1186.  
  1187.     /* make sure there aren't any more arguments */
  1188.     xllastarg(args);
  1189.  
  1190.     /* return the character */
  1191.     return (val);
  1192. }
  1193.  
  1194. /* xchr - convert an INT into a one character ascii string */
  1195. NODE *xchr(args)
  1196.   NODE *args;
  1197. {
  1198.     NODE *oldstk,val;
  1199.     char *sptr;
  1200.  
  1201.     /* create a new stack frame */
  1202.     oldstk = xlsave(&val,NULL);
  1203.  
  1204.     /* build return node */
  1205.     val.n_ptr = newnode(STR);
  1206.     val.n_ptr->n_str = sptr = stralloc(1);
  1207.     *sptr++ = xlmatch(INT,&args)->n_int;
  1208.     *sptr = 0;
  1209.  
  1210.     /* make sure there aren't any more arguments */
  1211.     xllastarg(args);
  1212.  
  1213.     /* restore the previous stack frame */
  1214.     xlstack = oldstk;
  1215.  
  1216.     /* return the new string */
  1217.     return (val.n_ptr);
  1218. }
  1219.  
  1220. /* xatoi - convert an ascii string to an integer */
  1221. NODE *xatoi(args)
  1222.   NODE *args;
  1223. {
  1224.     NODE *val;
  1225.     int n;
  1226.  
  1227.     /* get the string and convert it */
  1228.     n = atoi(xlmatch(STR,&args)->n_str);
  1229.  
  1230.     /* make sure there aren't any more arguments */
  1231.     xllastarg(args);
  1232.  
  1233.     /* create the value node */
  1234.     val = newnode(INT);
  1235.     val->n_int = n;
  1236.  
  1237.     /* return the number */
  1238.     return (val);
  1239. }
  1240.  
  1241. /* xitoa - convert an integer to an ascii string */
  1242. NODE *xitoa(args)
  1243.   NODE *args;
  1244. {
  1245.     NODE *val;
  1246.     char buf[20];
  1247.     int n;
  1248.  
  1249.     /* get the integer */
  1250.     n = xlmatch(INT,&args)->n_int;
  1251.     xllastarg(args);
  1252.  
  1253.     /* convert it to ascii */
  1254.     sprintf(buf,"%d",n);
  1255.  
  1256.     /* create the value node */
  1257.     val = newnode(STR);
  1258.     val->n_str = strsave(buf);
  1259.  
  1260.     /* return the string */
  1261.     return (val);
  1262. }
  1263. SHAR_EOF
  1264. if test 4134 -ne "`wc -c < 'xlstr.c'`"
  1265. then
  1266.     echo shar: error transmitting "'xlstr.c'" '(should have been 4134 characters)'
  1267. fi
  1268. fi # end of overwriting check
  1269. echo shar: extracting "'xlstub.c.XXX'" '(158 characters)'
  1270. if test -f 'xlstub.c.XXX'
  1271. then
  1272.     echo shar: will not over-write existing file "'xlstub.c.XXX'"
  1273. else
  1274. sed 's/^X//' << \SHAR_EOF > 'xlstub.c.XXX'
  1275. /* xlstub.c - stubs for replacing the 'xlobj' module */
  1276.  
  1277. #include "xlisp.h"
  1278.  
  1279. xloinit() {}
  1280. NODE *xlsend() { return (NIL); }
  1281. NODE *xlobsym() { return (NIL); }
  1282.  
  1283. SHAR_EOF
  1284. if test 158 -ne "`wc -c < 'xlstub.c.XXX'`"
  1285. then
  1286.     echo shar: error transmitting "'xlstub.c.XXX'" '(should have been 158 characters)'
  1287. fi
  1288. fi # end of overwriting check
  1289. echo shar: extracting "'xlsubr.c'" '(4232 characters)'
  1290. if test -f 'xlsubr.c'
  1291. then
  1292.     echo shar: will not over-write existing file "'xlsubr.c'"
  1293. else
  1294. sed 's/^X//' << \SHAR_EOF > 'xlsubr.c'
  1295. /* xlsubr - xlisp builtin function support routines */
  1296.  
  1297. #include "xlisp.h"
  1298.  
  1299. /* external variables */
  1300. extern NODE *k_test,*k_tnot,*s_eql;
  1301. extern NODE *xlstack;
  1302.  
  1303. /* xlsubr - define a builtin function */
  1304. xlsubr(sname,type,subr)
  1305.   char *sname; int type; NODE *(*subr)();
  1306. {
  1307.     NODE *sym;
  1308.  
  1309.     /* enter the symbol */
  1310.     sym = xlsenter(sname);
  1311.  
  1312.     /* initialize the value */
  1313.     sym->n_symvalue = newnode(type);
  1314.     sym->n_symvalue->n_subr = subr;
  1315. }
  1316.  
  1317. /* xlarg - get the next argument */
  1318. NODE *xlarg(pargs)
  1319.   NODE **pargs;
  1320. {
  1321.     NODE *arg;
  1322.  
  1323.     /* make sure the argument exists */
  1324.     if (!consp(*pargs))
  1325.     xlfail("too few arguments");
  1326.  
  1327.     /* get the argument value */
  1328.     arg = car(*pargs);
  1329.  
  1330.     /* make sure its not a keyword */
  1331.     if (symbolp(arg) && *car(arg->n_symplist)->n_str == ':')
  1332.     xlfail("too few arguments");
  1333.  
  1334.     /* move the argument pointer ahead */
  1335.     *pargs = cdr(*pargs);
  1336.  
  1337.     /* return the argument */
  1338.     return (arg);
  1339. }
  1340.  
  1341. /* xlmatch - get an argument and match its type */
  1342. NODE *xlmatch(type,pargs)
  1343.   int type; NODE **pargs;
  1344. {
  1345.     NODE *arg;
  1346.  
  1347.     /* get the argument */
  1348.     arg = xlarg(pargs);
  1349.  
  1350.     /* check its type */
  1351.     if (type == LIST) {
  1352.     if (arg && ntype(arg) != LIST)
  1353.         xlfail("bad argument type");
  1354.     }
  1355.     else {
  1356.     if (arg == NIL || ntype(arg) != type)
  1357.         xlfail("bad argument type");
  1358.     }
  1359.  
  1360.     /* return the argument */
  1361.     return (arg);
  1362. }
  1363.  
  1364. /* xlevarg - get the next argument and evaluate it */
  1365. NODE *xlevarg(pargs)
  1366.   NODE **pargs;
  1367. {
  1368.     NODE *oldstk,val;
  1369.  
  1370.     /* create a new stack frame */
  1371.     oldstk = xlsave(&val,NULL);
  1372.  
  1373.     /* get the argument */
  1374.     val.n_ptr = xlarg(pargs);
  1375.  
  1376.     /* evaluate the argument */
  1377.     val.n_ptr = xleval(val.n_ptr);
  1378.  
  1379.     /* restore the previous stack frame */
  1380.     xlstack = oldstk;
  1381.  
  1382.     /* return the argument */
  1383.     return (val.n_ptr);
  1384. }
  1385.  
  1386. /* xlevmatch - get an evaluated argument and match its type */
  1387. NODE *xlevmatch(type,pargs)
  1388.   int type; NODE **pargs;
  1389. {
  1390.     NODE *arg;
  1391.  
  1392.     /* get the argument */
  1393.     arg = xlevarg(pargs);
  1394.  
  1395.     /* check its type */
  1396.     if (type == LIST) {
  1397.     if (arg && ntype(arg) != LIST)
  1398.         xlfail("bad argument type");
  1399.     }
  1400.     else {
  1401.     if (arg == NIL || ntype(arg) != type)
  1402.         xlfail("bad argument type");
  1403.     }
  1404.  
  1405.     /* return the argument */
  1406.     return (arg);
  1407. }
  1408.  
  1409. /* xltest - get the :test or :test-not keyword argument */
  1410. xltest(pfcn,ptresult,pargs)
  1411.   NODE **pfcn; int *ptresult; NODE **pargs;
  1412. {
  1413.     NODE *arg;
  1414.  
  1415.     /* default the argument to eql */
  1416.     if (!consp(*pargs)) {
  1417.     *pfcn = s_eql->n_symvalue;
  1418.     *ptresult = TRUE;
  1419.     return;
  1420.     }
  1421.  
  1422.     /* get the keyword */
  1423.     arg = car(*pargs);
  1424.  
  1425.     /* check the keyword */
  1426.     if (arg == k_test)
  1427.     *ptresult = TRUE;
  1428.     else if (arg == k_tnot)
  1429.     *ptresult = FALSE;
  1430.     else
  1431.     xlfail("expecting :test or :test-not");
  1432.  
  1433.     /* move the argument pointer ahead */
  1434.     *pargs = cdr(*pargs);
  1435.  
  1436.     /* make sure the argument exists */
  1437.     if (!consp(*pargs))
  1438.     xlfail("no value for keyword argument");
  1439.  
  1440.     /* get the argument value */
  1441.     *pfcn = car(*pargs);
  1442.  
  1443.     /* if its a symbol, get its value */
  1444.     if (symbolp(*pfcn))
  1445.     *pfcn = xleval(*pfcn);
  1446.  
  1447.     /* move the argument pointer ahead */
  1448.     *pargs = cdr(*pargs);
  1449. }
  1450.  
  1451. /* xllastarg - make sure the remainder of the argument list is empty */
  1452. xllastarg(args)
  1453.   NODE *args;
  1454. {
  1455.     if (args)
  1456.     xlfail("too many arguments");
  1457. }
  1458.  
  1459. /* assign - assign a value to a symbol */
  1460. assign(sym,val)
  1461.   NODE *sym,*val;
  1462. {
  1463.     NODE *lptr;
  1464.  
  1465.     /* check for a current object */
  1466.     if ((lptr = xlobsym(sym)) != NIL)
  1467.     rplaca(lptr,val);
  1468.     else
  1469.     sym->n_symvalue = val;
  1470. }
  1471.  
  1472. /* eq - internal eq function */
  1473. int eq(arg1,arg2)
  1474.   NODE *arg1,*arg2;
  1475. {
  1476.     return (arg1 == arg2);
  1477. }
  1478.  
  1479. /* eql - internal eql function */
  1480. int eql(arg1,arg2)
  1481.   NODE *arg1,*arg2;
  1482. {
  1483.     if (eq(arg1,arg2))
  1484.     return (TRUE);
  1485.     else if (fixp(arg1) && fixp(arg2))
  1486.     return (arg1->n_int == arg2->n_int);
  1487.     else if (stringp(arg1) && stringp(arg2))
  1488.     return (strcmp(arg1->n_str,arg2->n_str) == 0);
  1489.     else
  1490.     return (FALSE);
  1491. }
  1492.  
  1493. /* equal - internal equal function */
  1494. int equal(arg1,arg2)
  1495.   NODE *arg1,*arg2;
  1496. {
  1497.     /* compare the arguments */
  1498.     if (eql(arg1,arg2))
  1499.     return (TRUE);
  1500.     else if (consp(arg1) && consp(arg2))
  1501.     return (equal(car(arg1),car(arg2)) && equal(cdr(arg1),cdr(arg2)));
  1502.     else
  1503.     return (FALSE);
  1504. }
  1505. SHAR_EOF
  1506. if test 4232 -ne "`wc -c < 'xlsubr.c'`"
  1507. then
  1508.     echo shar: error transmitting "'xlsubr.c'" '(should have been 4232 characters)'
  1509. fi
  1510. fi # end of overwriting check
  1511. echo shar: extracting "'xlsym.c'" '(3869 characters)'
  1512. if test -f 'xlsym.c'
  1513. then
  1514.     echo shar: will not over-write existing file "'xlsym.c'"
  1515. else
  1516. sed 's/^X//' << \SHAR_EOF > 'xlsym.c'
  1517. /* xlsym - symbol handling routines */
  1518.  
  1519. #include "xlisp.h"
  1520.  
  1521. /* external variables */
  1522. extern NODE *oblist,*keylist;
  1523. extern NODE *s_unbound;
  1524. extern NODE *xlstack;
  1525.  
  1526. /* forward declarations */
  1527. XFORWARD NODE *symenter();
  1528. XFORWARD NODE *xlmakesym();
  1529. XFORWARD NODE *findprop();
  1530.  
  1531. /* xlenter - enter a symbol into the oblist or keylist */
  1532. NODE *xlenter(name,type)
  1533.   char *name;
  1534. {
  1535.     return (symenter(name,type,(*name == ':' ? keylist : oblist)));
  1536. }
  1537.  
  1538. /* symenter - enter a symbol into a package */
  1539. LOCAL NODE *symenter(name,type,listsym)
  1540.   char *name; int type; NODE *listsym;
  1541. {
  1542.     NODE *oldstk,*lsym,*nsym,newsym;
  1543.     int cmp;
  1544.  
  1545.     /* check for nil */
  1546.     if (strcmp(name,"nil") == 0)
  1547.     return (NIL);
  1548.  
  1549.     /* check for symbol already in table */
  1550.     lsym = NIL;
  1551.     nsym = listsym->n_symvalue;
  1552.     while (nsym) {
  1553.     if ((cmp = strcmp(name,xlsymname(car(nsym)))) <= 0)
  1554.         break;
  1555.     lsym = nsym;
  1556.     nsym = cdr(nsym);
  1557.     }
  1558.  
  1559.     /* check to see if we found it */
  1560.     if (nsym && cmp == 0)
  1561.     return (car(nsym));
  1562.  
  1563.     /* make a new symbol node and link it into the list */
  1564.     oldstk = xlsave(&newsym,NULL);
  1565.     newsym.n_ptr = newnode(LIST);
  1566.     rplaca(newsym.n_ptr,xlmakesym(name,type));
  1567.     rplacd(newsym.n_ptr,nsym);
  1568.     if (lsym)
  1569.     rplacd(lsym,newsym.n_ptr);
  1570.     else
  1571.     listsym->n_symvalue = newsym.n_ptr;
  1572.     xlstack = oldstk;
  1573.  
  1574.     /* return the new symbol */
  1575.     return (car(newsym.n_ptr));
  1576. }
  1577.  
  1578. /* xlsenter - enter a symbol with a static print name */
  1579. NODE *xlsenter(name)
  1580.   char *name;
  1581. {
  1582.     return (xlenter(name,STATIC));
  1583. }
  1584.  
  1585. /* xlmakesym - make a new symbol node */
  1586. NODE *xlmakesym(name,type)
  1587.   char *name;
  1588. {
  1589.     NODE *oldstk,sym,*str;
  1590.  
  1591.     /* create a new stack frame */
  1592.     oldstk = xlsave(&sym,NULL);
  1593.  
  1594.     /* make a new symbol node */
  1595.     sym.n_ptr = newnode(SYM);
  1596.     sym.n_ptr->n_symvalue = (*name == ':' ? sym.n_ptr : s_unbound);
  1597.     sym.n_ptr->n_symplist = newnode(LIST);
  1598.     rplaca(sym.n_ptr->n_symplist,str = newnode(STR));
  1599.     str->n_str = (type == DYNAMIC ? strsave(name) : name);
  1600.     str->n_strtype = type;
  1601.  
  1602.     /* restore the previous stack frame */
  1603.     xlstack = oldstk;
  1604.  
  1605.     /* return the new symbol node */
  1606.     return (sym.n_ptr);
  1607. }
  1608.  
  1609. /* xlsymname - return the print name of a symbol */
  1610. char *xlsymname(sym)
  1611.   NODE *sym;
  1612. {
  1613.     return (car(sym->n_symplist)->n_str);
  1614. }
  1615.  
  1616. /* xlgetprop - get the value of a property */
  1617. NODE *xlgetprop(sym,prp)
  1618.   NODE *sym,*prp;
  1619. {
  1620.     NODE *p;
  1621.  
  1622.     return ((p = findprop(sym,prp)) ? car(p) : NIL);
  1623. }
  1624.  
  1625. /* xlputprop - put a property value onto the property list */
  1626. xlputprop(sym,val,prp)
  1627.   NODE *sym,*val,*prp;
  1628. {
  1629.     NODE *oldstk,p,*pair;
  1630.  
  1631.     if ((pair = findprop(sym,prp)) == NIL) {
  1632.     oldstk = xlsave(&p,NULL);
  1633.     p.n_ptr = newnode(LIST);
  1634.     rplaca(p.n_ptr,prp);
  1635.     rplacd(p.n_ptr,pair = newnode(LIST));
  1636.     rplaca(pair,val);
  1637.     rplacd(pair,cdr(sym->n_symplist));
  1638.     rplacd(sym->n_symplist,p.n_ptr);
  1639.     xlstack = oldstk;
  1640.     }
  1641.     rplaca(pair,val);
  1642. }
  1643.  
  1644. /* xlremprop - remove a property from a property list */
  1645. xlremprop(sym,prp)
  1646.   NODE *sym,*prp;
  1647. {
  1648.     NODE *last,*p;
  1649.  
  1650.     last = NIL;
  1651.     for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(last)) {
  1652.     if (car(p) == prp)
  1653.         if (last)
  1654.         rplacd(last,cdr(cdr(p)));
  1655.         else
  1656.         rplacd(sym->n_symplist,cdr(cdr(p)));
  1657.     last = cdr(p);
  1658.     }
  1659. }
  1660.  
  1661. /* findprop - find a property pair */
  1662. LOCAL NODE *findprop(sym,prp)
  1663.   NODE *sym,*prp;
  1664. {
  1665.     NODE *p;
  1666.  
  1667.     for (p = cdr(sym->n_symplist); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
  1668.     if (car(p) == prp)
  1669.         return (cdr(p));
  1670.     return (NIL);
  1671. }
  1672.  
  1673. /* xlsinit - symbol initialization routine */
  1674. xlsinit()
  1675. {
  1676.     /* initialize the oblist */
  1677.     oblist = xlmakesym("*oblist*",STATIC);
  1678.     oblist->n_symvalue = newnode(LIST);
  1679.     rplaca(oblist->n_symvalue,oblist);
  1680.  
  1681.     /* initialize the keyword list */
  1682.     keylist = xlsenter("*keylist*");
  1683.  
  1684.     /* enter the unbound symbol indicator */
  1685.     s_unbound = xlsenter("*unbound*");
  1686.     s_unbound->n_symvalue = s_unbound;
  1687. }
  1688. SHAR_EOF
  1689. if test 3869 -ne "`wc -c < 'xlsym.c'`"
  1690. then
  1691.     echo shar: error transmitting "'xlsym.c'" '(should have been 3869 characters)'
  1692. fi
  1693. fi # end of overwriting check
  1694. echo shar: extracting "'xlsys.c'" '(3003 characters)'
  1695. if test -f 'xlsys.c'
  1696. then
  1697.     echo shar: will not over-write existing file "'xlsys.c'"
  1698. else
  1699. sed 's/^X//' << \SHAR_EOF > 'xlsys.c'
  1700. /* xlsys.c - xlisp builtin system functions */
  1701.  
  1702. #include "xlisp.h"
  1703.  
  1704. /* external variables */
  1705. extern NODE *xlstack;
  1706. extern int anodes;
  1707.  
  1708. /* external symbols */
  1709. extern NODE *a_subr,*a_fsubr;
  1710. extern NODE *a_list,*a_sym,*a_int,*a_str,*a_obj,*a_fptr;
  1711. extern NODE *true;
  1712.  
  1713. /* xload - direct input from a file */
  1714. NODE *xload(args)
  1715.   NODE *args;
  1716. {
  1717.     NODE *oldstk,fname,*val;
  1718.     int vflag,pflag;
  1719.  
  1720.     /* create a new stack frame */
  1721.     oldstk = xlsave(&fname,NULL);
  1722.  
  1723.     /* get the file name, verbose flag and print flag */
  1724.     fname.n_ptr = xlmatch(STR,&args);
  1725.     vflag = (args ? xlarg(&args) != NIL : TRUE);
  1726.     pflag = (args ? xlarg(&args) != NIL : FALSE);
  1727.     xllastarg(args);
  1728.  
  1729.     /* load the file */
  1730.     val = (xlload(fname.n_ptr->n_str,vflag,pflag) ? true : NIL);
  1731.  
  1732.     /* restore the previous stack frame */
  1733.     xlstack = oldstk;
  1734.  
  1735.     /* return the status */
  1736.     return (val);
  1737. }
  1738.  
  1739. /* xgc - xlisp function to force garbage collection */
  1740. NODE *xgc(args)
  1741.   NODE *args;
  1742. {
  1743.     /* make sure there aren't any arguments */
  1744.     xllastarg(args);
  1745.  
  1746.     /* garbage collect */
  1747.     gc();
  1748.  
  1749.     /* return nil */
  1750.     return (NIL);
  1751. }
  1752.  
  1753. /* xexpand - xlisp function to force memory expansion */
  1754. NODE *xexpand(args)
  1755.   NODE *args;
  1756. {
  1757.     NODE *val;
  1758.     int n,i;
  1759.  
  1760.     /* get the new number to allocate */
  1761.     n = (args ? xlmatch(INT,&args)->n_int : 1);
  1762.     xllastarg(args);
  1763.  
  1764.     /* allocate more segments */
  1765.     for (i = 0; i < n; i++)
  1766.     if (!addseg())
  1767.         break;
  1768.  
  1769.     /* return the number of segments added */
  1770.     val = newnode(INT);
  1771.     val->n_int = i;
  1772.     return (val);
  1773. }
  1774.  
  1775. /* xalloc - xlisp function to set the number of nodes to allocate */
  1776. NODE *xalloc(args)
  1777.   NODE *args;
  1778. {
  1779.     NODE *val;
  1780.     int n,oldn;
  1781.  
  1782.     /* get the new number to allocate */
  1783.     n = xlmatch(INT,&args)->n_int;
  1784.  
  1785.     /* make sure there aren't any more arguments */
  1786.     xllastarg(args);
  1787.  
  1788.     /* set the new number of nodes to allocate */
  1789.     oldn = anodes;
  1790.     anodes = n;
  1791.  
  1792.     /* return the old number */
  1793.     val = newnode(INT);
  1794.     val->n_int = oldn;
  1795.     return (val);
  1796. }
  1797.  
  1798. /* xmem - xlisp function to print memory statistics */
  1799. NODE *xmem(args)
  1800.   NODE *args;
  1801. {
  1802.     /* make sure there aren't any arguments */
  1803.     xllastarg(args);
  1804.  
  1805.     /* print the statistics */
  1806.     stats();
  1807.  
  1808.     /* return nil */
  1809.     return (NIL);
  1810. }
  1811.  
  1812. /* xtype - return type of a thing */
  1813. NODE *xtype(args)
  1814.     NODE *args;
  1815. {
  1816.     NODE *arg;
  1817.  
  1818.     if (!(arg = xlarg(&args)))
  1819.     return (NIL);
  1820.  
  1821.     switch (ntype(arg)) {
  1822.     case SUBR:    return (a_subr);
  1823.     case FSUBR:    return (a_fsubr);
  1824.     case LIST:    return (a_list);
  1825.     case SYM:    return (a_sym);
  1826.     case INT:    return (a_int);
  1827.     case STR:    return (a_str);
  1828.     case OBJ:    return (a_obj);
  1829.     case FPTR:    return (a_fptr);
  1830.     default:    xlfail("bad node type");
  1831.     }
  1832. }
  1833.  
  1834. /* xbaktrace - print the trace back stack */
  1835. NODE *xbaktrace(args)
  1836.   NODE *args;
  1837. {
  1838.     int n;
  1839.  
  1840.     n = (args ? xlmatch(INT,&args)->n_int : -1);
  1841.     xllastarg(args);
  1842.     xlbaktrace(n);
  1843.     return (NIL);
  1844. }
  1845.  
  1846. /* xexit - get out of xlisp */
  1847. NODE *xexit(args)
  1848.   NODE *args;
  1849. {
  1850.     xllastarg(args);
  1851.     exit();
  1852. }
  1853. SHAR_EOF
  1854. if test 3003 -ne "`wc -c < 'xlsys.c'`"
  1855. then
  1856.     echo shar: error transmitting "'xlsys.c'" '(should have been 3003 characters)'
  1857. fi
  1858. fi # end of overwriting check
  1859. #    End of shell archive
  1860. exit 0
  1861.  
  1862.